perm filename CHS2.F4[1,VDS] blob
sn#098015 filedate 1974-04-18 generic text, type C, neo UTF8
COMMENT ā VALID 00009 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C *** TEST OF 'UPDATE', 'FIXN', 'SCIN'
C00005 00003 SUBROUTINE OUTPUT (SKIP)
C00012 00004 SUBROUTINE MESAGE
C00014 00005 SUBROUTINE CONTRL
C00015 00006 SUBROUTINE UPDATE
C00018 00007 SUBROUTINE ROUND (N)
C00020 00008 SUBROUTINE FIXN
C00021 00009 SUBROUTINE SCIN
C00024 ENDMK
Cā;
C *** TEST OF 'UPDATE', 'FIXN', 'SCIN'
C SUBROUTINES NEEDED: OUTPUT, MESAGE, CONTRL, UPDATE, ROUND, FIXN, SCIN
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG, JUMP, JMP, NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA X/102*0/,
* JUMP,JMP,NEXT/3*.FALSE./
1 ERROR=0
OLD=1
FIXFLG=.TRUE.
FIX=2
SCI=5
TYPE 100
ACCEPT 200, (X(1,I), I=1,17)
IF (X (1,1).GT.15) GO TO 9
NKEYS=99
DO 7 KEY=1,NKEYS
CALL CONTRL
IF (KEY.GT.1) GO TO 2
CALL UPDATE
CALL OUTPUT (1)
2 IF (JUMP) JUMP=.FALSE.
IF (CODE.EQ.32) GO TO 3
IF (CODE.EQ.33) GO TO 4
IF (CODE.EQ.99) GO TO 9
ERROR=1
GO TO 5
3 CALL FIXN
GO TO 5
4 CALL SCIN
5 IF (ERROR.GT.0) CALL MESAGE
CALL OUTPUT (1)
IF (ERROR.EQ.0) GO TO 6
ERROR=0
GO TO 8
6 IF (JUMP) GO TO 2
7 CONTINUE
8 GO TO 1
9 STOP
100 FORMAT (//' ENTER VALUE OF X(1,I), I=1,17'/)
200 FORMAT (17I)
END
SUBROUTINE OUTPUT (SKIP)
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
INTEGER*2 CHAR(39),STROKE(50),SIGN(6),ESN(6),DISPLY(16)
LOGICAL EEX, DP, START, FIXFLG
REAL*8 NAME(3)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
2 /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
3 /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
4 /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
2 CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
3 CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .','EE'/,
4 CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +',' ',' /'/,
5 CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
6 CHAR(21),CHAR(22),CHAR(23),CHAR(24)/'AB',' =',' A','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CX','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/' E','SV','->','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SN','IX','XC',' ;'/,
A CHAR(37),CHAR(38),CHAR(39) /' ,','LX','LY'/
DATA NAME /' A =', 'LAST X =','LAST Y ='/
IF (SKIP.LT.0) GO TO 30
10 DO 20 I=OLD,KEY
J=EXPR(I)
IF (J.EQ.0) J=10
20 STROKE(I)=CHAR(J)
TYPE 100, (STROKE(I),I=1,KEY)
OLD=KEY+1
IF (SKIP.EQ.2) GO TO 75
GO TO 60
30 DO 40 I=1,NKEYS
J=INPUT(I)
IF (J.EQ.0) J=10
40 STROKE(I)=CHAR(J)
TYPE 100, (STROKE(I),I=1,NKEYS)
DO 50 I=1,50
50 STROKE(I)=CHAR(15)
60 DO 70 I=1,6
J=X(I,1)
IF (J.EQ.0) J=15
SIGN(I)=CHAR(J)
K=X(I,15)
IF (K.EQ.0) K=15
70 ESN(I)=CHAR(K)
75 DO 80 I=1,16
J=D(I)
IF (J.EQ.0) J=10
80 DISPLY(I)=CHAR(J)
IF (SKIP.EQ.2) GO TO 95
IF (SKIP.EQ.1) GO TO 90
TYPE 200, P(6),SIGN(6),(X(6,N),N=2,14),ESN(6),X(6,16),
2 X(6,17),OP(6),START,L,
3 P(5),SIGN(5),(X(5,N),N=2,14),ESN(5),X(5,16),
4 X(5,17),OP(5),DP,M,
5 P(4),SIGN(4),(X(4,N),N=2,14),ESN(4),X(4,16),
6 X(4,17),OP(4),EEX,FIX,
7 P(3),SIGN(3),(X(3,N),N=2,14),ESN(3),X(3,16),
8 X(3,17),OP(3),FIXFLG,SCI
90 TYPE 300, P(2),SIGN(2),(X(2,N),N=2,14),ESN(2),X(2,16),
2 X(2,17),OP(2),ERROR
TYPE 400, P(1),SIGN(1),(X(1,N),N=2,14),ESN(1),X(1,16),
2 X(1,17),OP(1)
95 TYPE 500, DISPLY
IF (SKIP.NE.0) RETURN
DO 96 I=2,4
IF (R(I,2).NE.15) TYPE 600, NAME(I), (R(I,N), N=1,17)
96 CONTINUE
DO 97 I=5,20
IF (R(I,2).EQ.15) GO TO 97
J=I-5
TYPE 700, J, (R(I,N), N=1,17)
97 CONTINUE
RETURN
100 FORMAT (6X,'EXPRESSION: ',39A3/30X,11A3)
200 FORMAT (//14X,'STACK: S(6) -',4X,I2,' / ',A2,I2,' .',12I2,
2 A2,2I2,' /',I3,10X,'FLAGS: START - ',L2,10X,
3 'INDICES: L -',I3//
4 22X,'S(5) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
5 I3,18X,'DP - ',L2,20X,'M -',I3//
6 22X,'S(4) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
7 I3,18X,'EEX - ',L2,20X,'FIX-',I3//
8 22X,'S(3) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
9 I3,18X,'FIXFLG- ',L2,20X,'SCI-'I3)
300 FORMAT (/22X,'S(2) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
2 I3,18X,'ERROR - ',I2/)
400 FORMAT (22X,'S(1) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',I3//)
500 FORMAT (14X,'DISPLAY:',9X,16A3///)
600 FORMAT (22X,A8,I3,I2,' .',15I2)
700 FORMAT (22X,'REG(',I2,') =',I3,I2,' .',15I2)
END
SUBROUTINE MESAGE
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DO 1 I=1,17
1 R(3,I)=X(1,I)
OP(1)=1
D(1)=15
DO 2 I=2,16
2 D(I)=13
D(8)=29
D(9)=ERROR/10
D(10)=ERROR-10*D(9)
IF (ERROR.GT.1) GO TO 3
D(15)=CODE/10
D(16)=CODE-10*D(15)
3 RETURN
END
SUBROUTINE CONTRL
C DATE OF LAST CHANGE - 740101
IMPLICIT INTEGER (A-Z)
DIMENSION INPUT(50), EXPR(50)
COMMON /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
TYPE 1
ACCEPT 2, CODE
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
RETURN
1 FORMAT (' ?'/)
2 FORMAT (I)
END
SUBROUTINE UPDATE
C DATE OF LAST CHANGE - 740209
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
D(1)=X(1,1)
D(2)=X(1,2)
IF (.NOT.FIXFLG) GO TO 12
C DISPLAY IN "FIX" FORMAT
IF (X(1,16).GT.0) GO TO 12
EXPX=X(1,17)
IF (X(1,15).EQ.13) GO TO 5
K=EXPX+FIX+1
IF (K.GT.10) GO TO 12
DO 1 I=13,16
1 D(I)=15
CALL ROUND (K)
K=EXPX+2
DO 2 I=3,K
2 D(I)=W(I)
K=K+1
D(K)=11
IF (FIX.EQ.0) GO TO 4
DO 3 I=1,FIX
3 D(I+K)=W(I+K-1)
4 K=K+FIX+1
GO TO 15
5 D(2)=10
D(3)=11
K=FIX-EXPX+1
IF (K.LE.0) GO TO 8
CALL ROUND (K)
J=EXPX+2
DO 6 I=4,J
6 D(I)=10
DO 7 I=1,K
7 D(J+I)=W(I+1)
GO TO 10
8 J=FIX+3
DO 9 I=4,J
9 D(I)=10
10 K=FIX+4
DO 11 I=13,16
11 D(I)=15
GO TO 15
C DISPLAY IN "SCI" FORMAT
12 CALL ROUND (SCI)
D(13)=29
DO 13 I=14,16
13 D(I)=W(I+1)
D(3)=11
K=SCI+3
DO 14 I=5,K
14 D(I-1)=W(I-2)
15 DO 16 I=K,12
16 D(I)=15
RETURN
END
SUBROUTINE ROUND (N)
C DATE OF LAST CHANGE - 740209
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DO 1 I=1,17
1 W(I)=X(1,I)
IF (W(N+2)-5) 6,2,4
2 K=N+3
DO 3 I=K,14
IF (W(I).GT.0) GO TO 4
3 CONTINUE
K=N+1
IF (2*(W(K)/2) .EQ. W(K)) GO TO 6
4 K=N+1
W(K)=W(K)+1
DO 5 I=3,K
J=N+4-I
IF (W(J).LT.10) GO TO 6
W(J)=W(J)-10
5 W(J-1)=W(J-1)+1
6 RETURN
END
SUBROUTINE FIXN
IMPLICIT INTEGER (A-Z)
LOGICAL JUMP, FIXFLG
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.TRUE.
KEY=KEY+1
CALL CONTRL
IF (CODE.LT.11) GO TO 1
JUMP=.TRUE.
GO TO 2
1 FIX=CODE
2 CALL UPDATE
RETURN
END
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 740225
IMPLICIT INTEGER (A-Z)
LOGICAL JUMP, FIXFLG
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.FALSE.
KEY=KEY+1
CALL CONTRL
IF (CODE.LT.11) GO TO 1
JUMP=.TRUE.
GO TO 2
1 SCI=CODE+1
IF (SCI.EQ.11) SCI=1
2 CALL UPDATE
RETURN
END